home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / totsrc11.zip / TOTDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-04  |  16KB  |  615 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.10                             }
  6.  
  7. Unit totDATE;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes:
  12.            1.00a   ??/??/??   Corrected calc of Year
  13.            1.00b   06/01/91   Corrected 1.00a!
  14.            1.00c   02/03/92   Changed Leap Year validation
  15.            1.00d   02/27/92   Corrected DateFormat function
  16.            1.00e   03/09/92   Changed 1900+ operation for 0..99 years
  17.            1.10a   05/05/93   Changed ret value on JultoGreg and GregToStr
  18.                               when 0 values passed.
  19. }
  20.  
  21. INTERFACE
  22.  
  23. Uses DOS,totLOOK,totSTR;
  24.  
  25. Type
  26.  
  27. tDate = (MMDDYY,MMDDYYYY,MMYY,MMYYYY,DDMMYY,DDMMYYYY,YYMMDD,YYYYMMDD);
  28. StrShort = string[20];
  29.  
  30. tMonths  = array[1..12] of StrShort;
  31. tDays = array[0..6] of StrShort;
  32.  
  33. pDateOBJ = ^DateOBJ;
  34. DateOBJ = object
  35.    vLastYearNextCentury: byte;
  36.    vSeparator: char;
  37.    vMonths: tMonths;
  38.    vDays: tDays;
  39.    {methods...}
  40.    constructor Init;
  41.    procedure   SetLastYearNextCentury(Yr:byte);
  42.    procedure   SetSeparator(Sep:char);
  43.    procedure   SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: strshort);
  44.    procedure   SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:strshort);
  45.    function    GetLastYearNextCentury: byte;
  46.    function    GetSeparator: char;
  47.    function    GetMonth(Mth:byte):string;
  48.    function    GetDay(Day:byte):string;
  49.    destructor  Done;
  50. end; {DateOBJ}
  51.  
  52. function  GregtoJul(M,D,Y : longint): longint;
  53. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  54. function  Day(DStr:string;Format:tDate): word;
  55. function  Month(DStr:string;Format:tDate): word;
  56. function  Year(DStr:string;Format:tDate): word;
  57. function  StrtoJul(DStr:string;Format:tDate):longint;
  58. function  DOWStr(DStr:string;Format:tDate): byte;
  59. function  DOWJul(Jul:longint): byte;
  60. function  GregtoStr(M,D,Y:longint;Format:tDate): string;
  61. function  JultoStr(Jul:longint;Format:tDate): string;
  62. function  TodayinJul: longint;
  63. function  ValidDate(M,D,Y:longint):boolean;
  64. function  ValidDateStr(DStr:string;Format:tDate): boolean;
  65. function  StripDateStr(DStr:string;Format:tDate):string;
  66. function  FancyDateStr(Jul:longint; Long,Day:boolean): string;
  67. function  RelativeDate(DStr:string;Format:tDate;Delta:longint):string;
  68. function  StartOfYear(Jul:longint):longint;
  69. function  EndOfYear(Jul:longint):longint;
  70. function  DateFormat(Format:tDate):string;
  71. procedure DateInit;
  72.  
  73. var
  74.  
  75.   DateTOT: ^DateOBJ;
  76.  
  77. IMPLEMENTATION
  78.  
  79. {|||||||||||||||||||||||||||||||||||||||}
  80. {                                       }
  81. {     D a t e O B J   M E T H O D S     }
  82. {                                       }
  83. {|||||||||||||||||||||||||||||||||||||||}
  84. constructor DateOBJ.Init;
  85. {}
  86. begin
  87.    vLastYearNextCentury := 20;
  88.    vSeparator := '/';
  89.    SetDays('Sunday','Monday','Tuesday','Wednesday',
  90.            'Thursday','Friday','Saturday');
  91.    SetMonths('January','February','March','April','May',
  92.              'June','July','August','September',
  93.              'October','November','December');
  94. end; {DateOBJ.Init}
  95.  
  96. function DateOBJ.GetLastYearNextCentury: byte;
  97. {}
  98. begin
  99.    GetLastYearNextCentury := vLastYearNextCentury;
  100. end; {DateOBJ.GetLastYearNextCentury}
  101.  
  102. procedure DateOBJ.SetLastYearNextCentury(Yr:byte);
  103. {}
  104. begin
  105.    {$IFDEF CHECK}
  106.      if (Yr >= 0) and (Yr <= 99) then
  107.         vLastYearNextCentury := Yr;
  108.    {$ELSE}
  109.      vLastYearNextCentury := Yr;
  110.    {$ENDIF}
  111. end; {DateOBJ.GetLastYearNextCentury}
  112.  
  113. function DateOBJ.GetSeparator: char;
  114. {}
  115. begin
  116.    GetSeparator := vSeparator;
  117. end; {DateOBJ.GetSeparator}
  118.  
  119. procedure DateOBJ.SetSeparator(Sep:char);
  120. {}
  121. begin
  122.    vSeparator := Sep;
  123. end; {DateOBJ.SetSeparator}
  124.  
  125. procedure DateOBJ.SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: StrShort);
  126. {}
  127. begin
  128.    vMonths[1] := Mth1;
  129.    vMonths[2] := Mth2;
  130.    vMonths[3] := Mth3;
  131.    vMonths[4] := Mth4;
  132.    vMonths[5] := Mth5;
  133.    vMonths[6] := Mth6;
  134.    vMonths[7] := Mth7;
  135.    vMonths[8] := Mth8;
  136.    vMonths[9] := Mth9;
  137.    vMonths[10] := Mth10;
  138.    vMonths[11] := Mth11;
  139.    vMonths[12] := Mth12;
  140. end; {DateOBJ.SetMonths}
  141.  
  142. procedure DateOBJ.SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:StrShort);
  143. {}
  144. begin
  145.    vDays[0] := Day0;
  146.    vDays[1] := Day1;
  147.    vDays[2] := Day2;
  148.    vDays[3] := Day3;
  149.    vDays[4] := Day4;
  150.    vDays[5] := Day5;
  151.    vDays[6] := Day6;
  152. end; {DateOBJ.SetDays}
  153.  
  154. function DateOBJ.GetMonth(Mth:byte):string;
  155. {}
  156. begin
  157.    if Mth in [2..12] then
  158.       GetMonth := vMonths[Mth]
  159.    else
  160.       GetMonth := vMonths[1];
  161. end; {DateOBJ.GetMonth}
  162.  
  163. function DateOBJ.GetDay(Day:byte):string;
  164. {}
  165. begin
  166.    if Day in [1..6] then
  167.       GetDay := vDays[Day]
  168.    else
  169.       GetDay := vDays[0];
  170. end; {DateOBJ.GetDay}
  171.  
  172. destructor DateOBJ.Done;
  173. begin end;
  174. {|||||||||||||||||||||||||||||||||||||||||||}
  175. {                                           }
  176. {     M i s c   P r o c   &   F u n c s     }
  177. {                                           }
  178. {|||||||||||||||||||||||||||||||||||||||||||}
  179. function PadDateStr(DStr:string;Format:tDate):string;
  180. {}
  181. var
  182.    Part1,Part2,Part3: string;
  183.    L,P: byte;
  184.    Sep1,Sep2:char;
  185.  
  186.      procedure PadOut(var S:string; width:byte);
  187.      begin
  188.         S := padright(S,width,'0');
  189.      end;
  190.  
  191. begin
  192.    if length(DStr) = length(DateFormat(Format)) then
  193.    begin
  194.       PadDateStr := DStr;
  195.       exit;
  196.    end;
  197.    P := 0;
  198.    L := length(DStr);
  199.    repeat
  200.       inc(P);
  201.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  202.    if P > L then
  203.    begin
  204.       PadDateStr := DStr;
  205.       exit;
  206.    end;
  207.    Part1 := copy(DStr,1,pred(P));
  208.    Sep1 := DStr[P];
  209.    delete(DStr,1,P);
  210.    P:= 0;
  211.    repeat
  212.       inc(P);
  213.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  214.    Part2 := copy(DStr,1,pred(P));
  215.    Sep2 := DStr[P];
  216.    Part3 := copy(DStr,succ(P),4);
  217.    case Format of
  218.       MMDDYY,YYMMDD,DDMMYY:begin
  219.           PadOut(Part1,2);
  220.           PadOut(Part2,2);
  221.           PadOut(Part3,2);
  222.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  223.       end;
  224.       MMDDYYYY,DDMMYYYY:begin
  225.           PadOut(Part1,2);
  226.           PadOut(Part2,2);
  227.           PadOut(Part3,4);
  228.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  229.       end;
  230.       YYYYMMDD:begin
  231.           PadOut(Part1,4);
  232.           PadOut(Part2,2);
  233.           PadOut(Part3,2);
  234.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  235.       end;
  236.       MMYY:begin
  237.           PadOut(Part1,2);
  238.           PadOut(Part2,2);
  239.           DStr := Part1+Sep1+Part2;
  240.       end;
  241.       MMYYYY:begin
  242.           PadOut(Part1,2);
  243.           PadOut(Part2,4);
  244.           DStr := Part1+Sep1+Part2;
  245.       end;
  246.    end; {case}
  247.    PadDateStr := DStr;
  248. end; {PadDateStr}
  249.  
  250. function GregtoJul(M,D,Y:longint):longint;
  251. {}
  252. var Factor: integer;
  253. begin
  254.    if M < 3 then
  255.       Factor := -1
  256.    else
  257.       Factor := 0;
  258.    GregtoJul :=  (1461*(Factor+4800+Y) div 4)
  259.                + ((M-2-(Factor*12))*367) div 12
  260.                - (3*((Y+4900+Factor) div 100) div 4)
  261.                + D
  262.                - 32075;
  263. end; {GregtoJul}
  264.  
  265. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  266. {}
  267. var U,V,W,X: longint;
  268. begin
  269.    if Jul = 0 then {1.10a}
  270.    begin
  271.       M := 0;
  272.       D := 0;
  273.       Y := 0;
  274.    end
  275.    else
  276.    begin
  277.       inc(Jul,68569);
  278.       W := (Jul*4) div 146097;
  279.       dec(Jul,((146097*W)+3) div 4);
  280.       X := 4000*succ(Jul) div 1461001;
  281.       dec(Jul,((1461*X) div 4) - 31);
  282.       V := 80*Jul div 2447;
  283.       U := V div 11;
  284.       D := Jul - (2447*V div 80);
  285.       M := V + 2 - (U*12);
  286.       Y := X + U + (W-49)*100;
  287.    end;
  288. end; {JultoGreg}
  289.  
  290. function Day(DStr:string;Format:tDate): word;
  291. {}
  292. var
  293.    DayStr: string;
  294. begin
  295.    DStr := PadDateStr(DStr,Format);
  296.    case Format of
  297.       MMDDYY,
  298.       MMDDYYYY: DayStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  299.       DDMMYY,
  300.       DDMMYYYY: DayStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  301.       YYMMDD:   DayStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  302.       YYYYMMDD: DayStr := NthNumber(D